home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
c
/
process.d
< prev
next >
Wrap
Lisp/Scheme
|
1986-05-30
|
13KB
|
613 lines
/*
(C) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
*/
/*
process.d
DG-SPECIFIC
*/
/*
create a son process
(process "progname.pr"
&optional "ipc-message"
&key :block :console :debug :dir :username :list :data :ioc :prtype)
progname.pr Speicfy program name. ".pr" is not added automatically.
ipc-message Specify ipc message passed to progname.pr. You must
follow the IPC message rule. For example, you must
split each argument by "," characater.
The default is an empty string.
:block t block the lisp until new process terminates
The default is T.
:console ":PER:CON??" set process console to :PER:CON??
:debug t begin execution in the debugger
:dir "PATHNAME" set intitial working directory to PATHNAME
:username "USER" set user name to USER
:list "LISTFILE" set :PER:LIST to LISTFILE
:list t set :PER:LIST to :PER:LIST of lisp
:data "DATAFILE" set :PER:DATA to DATAFILE
:data t set :PER:DATA to :PER:DATA of lisp
:ioc t set :PER:INPUT, :PER:OUTPUT and :PER:CONSOLE
same as lisp
The default is T.
:prtype TYPE set the process type to TYPE
TYPE should be one of
:swappable (default)
:pre-emptive
:resident
*/
#include <sysid.h>
#include <paru.h>
#include <packets:ipc.h>
#include <packets:process.h>
#include <packets:create.h> /**/
#include "include.h"
static object Kblock;
static object Kconsole;
static object Kdebug;
static object Kdir;
static object Kusername;
static object Klist;
static object Kdata;
static object Kioc;
static object Kprtype;
static object Kswappable;
static object Kpre_emptive;
static object Kresident;
static
string_copy(x, buff)
object x;
char *buff;
{
int i, j;
char *c;
j = x->st.st_fillp;
c = x->st.st_self;
for (i = 0; i < j; i++)
buff[i] = c[i];
buff[i] = '\0';
}
@(defun process (progname
&optional (message `make_simple_string("")`)
&key (block Ct) console debug dir input output username
list data (ioc Ct)
(prtype Kswappable))
object s;
int ier, ac0, ac1, ac2, ac3;
int i, j, len;
char *c;
char prog[256];
char mess[512];
char dirname[256];
char consname[256];
char inputname[256];
char outputname[256];
char user[256];
char listname[256];
char dataname[256];
P_PROC pack;
P_ISEND pack1;
@
check_type_string(&progname);
check_type_string(&message);
j = progname->st.st_fillp;
c = progname->st.st_self;
if (j > 255)
FEerror("The program name ~A is too long.", 1, progname);
for (i = 0; i < j; i++) /* copy program name */
prog[i] = toupper(c[i]);
prog[i] = '\0';
j = message->st.st_fillp;
c = message->st.st_self;
if (j > 510)
FEerror("The ipc message ~A is too long.", 1, message);
for (i = 0; i < j; i++) /* copy ipc message */
mess[i] = c[i];
mess[i++] = '\0';
mess[i] = '\0';
len = (i + 1) / 2; /* ipc message length */
/* build ?proc packet */
pack.pflg = 0;
if (block != Cnil) pack.pflg |= $PFEX;
if (debug != Cnil) pack.pflg |= $PFDB;
if (prtype == Kswappable)
;
else if (prtype == Kpre_emptive)
pack.pflg |= $PFRP;
else if (prtype == Kresident)
pack.pflg |= $PFRS;
else
FEerror("~S is an illegal process type.", 1, prtype);
pack.ppri = -1;
pack.psnm = prog;
pack.pipc = &pack1;
pack.pnm = -1;
pack.pmem = -1;
pack.pdir = -1;
if (dir != Cnil) {
if (type_of(dir) != t_string)
FEwrong_type_argument(Sstring, dir);
string_copy(dir, dirname);
pack.pdir = dirname;
}
if (ioc != Cnil) {
pack.pcon = -1;
pack.pifp = -1;
pack.pofp = -1;
} else {
pack.pcon = 0;
pack.pifp = 0;
pack.pofp = 0;
}
if (console != Cnil) {
if (type_of(console) != t_string)
FEwrong_type_argument(Sstring, console);
string_copy(console, consname);
pack.pcon = consname;
}
pack.pcal = -1;
pack.pwss = -1;
pack.punm = -1;
if (username != Cnil) {
if (type_of(username) != t_string)
FEwrong_type_argument(Sstring, username);
string_copy(username, user);
pack.punm = user;
}
pack.pprv = -1;
pack.ppcr = -1;
pack.pwmi = -1;
pack.proc_res = -1;
if (input != Cnil) {
if (type_of(input) != t_string)
FEwrong_type_argument(Sstring, input);
string_copy(input, inputname);
pack.pifp = inputname;
}
if (output != Cnil) {
if (type_of(output) != t_string)
FEwrong_type_argument(Sstring, output);
string_copy(output, outputname);
pack.pofp = outputname;
}
pack.plfp= 0;
if (list != Cnil)
if (list = Ct)
pack.plfp = -1;
else {
if (type_of(list) != t_string)
FEwrong_type_argument(Sstring, list);
string_copy(list, listname);
pack.plfp = listname;
}
pack.pdfp= 0;
if (data != Cnil)
if (data = Ct)
pack.pdfp = -1;
else {
if (type_of(data) != t_string)
FEwrong_type_argument(Sstring, data);
string_copy(data, dataname);
pack.pdfp = dataname;
}
pack.smch= -1;
/* build ipc packet */
pack1.isfl = 0;
pack1.iufl = $RFCF; /* cli format */
pack1.idph = 0;
pack1.iopn = 0;
pack1.ilth = len;
pack1.iptr = (short *)mess;
ac2 = &pack;
if (ier = sys($PROC,&ac0,&ac1,&ac2))
sys_emes(ier);
@(return Ct)
@)
check_termination(ms)
char *ms;
{
int ier, ac0, ac1, ac2, ac3, pc, carry, trap;
int i, j;
short fl;
char rmess[512];
P_ISEND pack;
zero(rmess, 512);
pack.isfl = $IFNBK;
pack.iufl = 0;
pack.idph = $SPTM;
pack.iopn = 0;
pack.iptr = (short *)rmess;
pack.ilth = 256;
ac2 = &pack;
ier = sys($IREC, &ac0, &ac1,&ac2);
if (ier == ERNMS)
return(FALSE);
if (ier != 0) sys_emes(ier);
fl = pack.iufl;
switch(fl & 03400) {
case $TEXT:
if (*(short *)rmess == $TR32) goto TRAP32;
ms[0] = '\0';
if (fl & $RFEC) {
if (fl & $RFWA)
strcpy(ms, "*WARNING*\n");
else if (fl & $RFER)
strcpy(ms, "*ERROR*\n");
else
strcpy(ms, "*ABORT*\n");
}
if (*((short *)rmess + 1) != 0) {
strcat(ms, rmess+8);
if (fl & $RFEC) strcat(ms, "\n");
}
if (fl & $RFEC) {
ier = *(int *)(rmess + 4);
getemes(ier, rmess);
strcat(ms, rmess);
}
return(TRUE);
case $TSELF:
ms[0] = '\0';
if (fl & $RFEC) {
if (fl & $RFWA)
strcpy(ms, "*WARNING*\n");
else if (fl & $RFER)
strcpy(ms, "*ERROR*\n");
else
strcpy(ms, "*ABORT*\n");
}
if (*(short *)rmess != 0) {
strcat(ms, rmess+4);
if (fl & $RFEC) strcat(ms, "\n");
}
if (fl & $RFEC) {
ier = *(short *)(rmess + 2);
getemes(ier, rmess);
strcat(ms, rmess);
}
return(TRUE);
case $TRAP:
ac0 = *(short *)(rmess + 0);
ac1 = *(short *)(rmess + 2);
ac2 = *(short *)(rmess + 4);
ac3 = *(short *)(rmess + 6);
pc = *(short *)(rmess + 8);
carry = (pc & 0100000) ? 1 : 0;
pc &= 077777;
sprintf(ms,
"*TRAP*\nC: %o PC: %o AC0: %o AC1: %o AC2: %o AC3: %o",
carry, pc, ac0, ac1, ac2, ac3);
return(TRUE);
case $TCIN:
strcpy(ms, "*ABORT*\nCONSOLE INTERRUPT");
return(TRUE);
case $TSUP:
strcpy(ms,"*ABORT*\nTERMINATED BY A SUPERIOR PROCESS");
return(TRUE);
case $TAOS:
ier = pack.iptr;
getemes(ier, rmess);
strcpy(ms, "TERMINATED BY AOS/VS\n");
strcat(ms, rmess);
return(TRUE);
default:
ms[0] = '\0';
return(TRUE);
} /* end of switch */
TRAP32:
ac0 = *(int *)(rmess + 2);
ac1 = *(int *)(rmess + 6);
ac2 = *(int *)(rmess + 10);
ac3 = *(int *)(rmess + 14);
pc = *(int *)(rmess + 18);
carry = (pc & 020000000000) ? 1:0;
pc &= 017777777777;
sprintf(ms,
"*TRAP*\nC: %o PC: %o AC0: %o AC1: %o AC2: %o AC3: %o",
carry, pc, ac0, ac1, ac2, ac3);
return(TRUE);
}
Ltermination_message()
{
char mess[512];
check_arg(0);
zero(mess, 512);
if (check_termination(mess) == TRUE)
vs_push(make_simple_string(mess));
else
vs_push(Cnil);
}
Llast_termination_message()
{
char mess[512], mess1[512];
int i;
check_arg(0);
i = 0;
zero(mess, 512);
while (check_termination(mess) == TRUE) {
i++;
blockmove(mess1, mess, 512);
zero(mess);
}
if (i > 0)
vs_push(make_simple_string(mess1));
else
vs_push(Cnil);
}
/*
IPC routines
SI:ILKUP
SI:IREC
SI:ISEND
SI:CREATE-IPC-FILE
*/
/*
(SI:ILKUP pathname)
returns the global port number of the IPC file `pathname'.
*/
siLilkup()
{
int ac0, ac1, ac2;
char buffer[2048];
int i, ier;
check_arg(1);
check_type_or_pathname_string_symbol_stream(&vs_base[0]);
vs_base[0] = coerce_to_pathname(vs_base[0]);
vs_base[0] = coerce_to_namestring(vs_base[0]);
if (vs_base[0]->st.st_fillp > 2047)
FEerror("The namestring ~A is too long.", 1, vs_base[0]);
for (i = 0; i < vs_base[0]->st.st_fillp; i++)
buffer[i] = vs_base[0]->st.st_self[i];
buffer[i] = '\0';
ac0 = (int)buffer;
ac1 = 0;
ac2 = 0;
ier = sys($ILKUP, &ac0, &ac1, &ac2);
if (ier != 0)
sys_emes(ier);
vs_base[0] = make_fixnum(ac1);
}
/*
(SI:IREC global-port-number local-port-number string)
receives a message from the specified port into `string'.
`string' must have a fill-pointer.
The port numbers should be fixnums.
*/
siLirec()
{
int ac0, ac1, ac2;
struct p_irec p;
char buffer[2048];
char *s;
int f, d;
int i, ier;
check_arg(3);
if (type_of(vs_base[0]) != t_fixnum)
FEerror("~S is an illegal global port number.",1,vs_base[0]);
if (type_of(vs_base[1]) != t_fixnum)
FEerror("~S is an illegal local port number.", 1, vs_base[1]);
check_type_string(&vs_base[2]);
if (!vs_base[2]->st.st_hasfillp)
FEerror("~S does not have a fill-pointer.", 1, vs_base[2]);
p.isfl = 0;
p.iufl = 0;
p.ioph = fix(vs_base[0]);
p.idpn = fix(vs_base[1]);
f = vs_base[2]->st.st_fillp;
d = vs_base[2]->st.st_dim - f;
s = vs_base[2]->st.st_self + f;
if ((int)s & 1) {
p.ilth = d/2 < 2048 ? d/2 : 2048;
p.iptr = buffer;
ac0 = 0;
ac1 = 0;
ac2 = (int)(&p);
if (ier = sys($IREC, &ac0, &ac1, &ac2))
sys_emes(ier);
for (i = 0; i < p.ilth*2; i++)
s[i] = buffer[i];
vs_base[2]->st.st_fillp += p.ilth*2;
} else {
p.ilth = d/2;
p.iptr = s;
ac0 = 0;
ac1 = 0;
ac2 = (int)(&p);
if (ier = sys($IREC, &ac0, &ac1, &ac2))
sys_emes(ier);
vs_base[2]->st.st_fillp += p.ilth*2;
}
vs_pop;
vs_pop;
vs_base[0] = Cnil;
}
/*
(SI:ISEND global-port-number local-port-number string)
sends a message in `string' to the specified port.
The length of `string' must be even.
The port numbers should be fixnums.
*/
siLisend()
{
int ac0, ac1, ac2;
struct p_isend p;
char buffer[2048];
char *s;
int f;
int i, ier;
check_arg(3);
if (type_of(vs_base[0]) != t_fixnum)
FEerror("~S is an illegal global port number.",1,vs_base[0]);
if (type_of(vs_base[1]) != t_fixnum)
FEerror("~S is an illegal local port number", 1, vs_base[1]);
check_type_string(&vs_base[2]);
if (vs_base[2]->st.st_fillp%2 != 0)
FEerror("The length of the message ~A is odd.",1,vs_base[2]);
p.isfl = 0;
p.iufl = 0;
p.idph = fix(vs_base[0]);
p.iopn = fix(vs_base[1]);
f = vs_base[2]->st.st_fillp;
s = vs_base[2]->st.st_self;
p.ilth = f/2;
if ((int)s & 1) {
if (f > 2048)
FEerror("The message ~S is too long.", 1, vs_base[2]);
for (i = 0; i < f; i++)
buffer[i] = s[i];
p.iptr = buffer;
} else
p.iptr = s;
ac0 = 0;
ac1 = 0;
ac2 = (int)(&p);
ier = sys($ISEND, &ac0, &ac1, &ac2);
if (ier != 0)
sys_emes(ier);
vs_pop;
vs_pop;
vs_base[0] = Cnil;
}
/*
(SI:CREATE-IPC-FILE pathname local-port-number)
creates an IPC file named `pathname'.
`local-port-number' is given to the IPC file.
It should be a fixnum.
*/
siLcreate_ipc_file()
{
int ac0, ac1, ac2;
struct p_create_ipc p;
char buffer[2048];
int i, ier;
check_arg(2);
check_type_or_pathname_string_symbol_stream(&vs_base[0]);
vs_base[0] = coerce_to_pathname(vs_base[0]);
vs_base[0] = coerce_to_namestring(vs_base[0]);
if (vs_base[0]->st.st_fillp > 2047)
FEerror("The namestring ~A is too long.", 1, vs_base[0]);
for (i = 0; i < vs_base[0]->st.st_fillp; i++)
buffer[i] = vs_base[0]->st.st_self[i];
buffer[i] = '\0';
if (type_of(vs_base[1]) != t_fixnum)
FEerror("~S is an illegal local port number.", 1, vs_base[1]);
p.cftyp_entry = $FIPC;
p.cpor = fix(vs_base[1]);
p.ctim = -1;
p.cacp = -1;
ac0 = (int)buffer;
ac1 = 0;
ac2 = (int)(&p);
if (ier = sys($CREATE, &ac0, &ac1, &ac2))
sys_emes(ier);
vs_pop;
vs_base[0] = Cnil;
}
init_process(start, size, data)
char *start;
int size;
object data;
{
Kblock = make_keyword("BLOCK");
Kconsole = make_keyword("CONSOLE");
Kdebug = make_keyword("DEBUG");
Kdir = make_keyword("DIR");
Kusername = make_keyword("USERNAME");
Klist = make_keyword("LIST");
Kdata = make_keyword("DATA");
Kioc = make_keyword("IOC");
Kprtype = make_keyword("PRTYPE");
Kswappable = make_keyword("SWAPPABLE");
Kpre_emptive = make_keyword("PRE-EMPTIVE");
Kresident = make_keyword("RESIDENT");
make_function("PROCESS", Lprocess);
make_function("TERMINATION-MESSAGE", Ltermination_message);
make_function("LAST-TERMINATION-MESSAGE",
Llast_termination_message);
make_si_function("ILKUP", siLilkup);
make_si_function("IREC", siLirec);
make_si_function("ISEND", siLisend);
make_si_function("CREATE-IPC-FILE", siLcreate_ipc_file);
}